home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tkSend.c < prev    next >
C/C++ Source or Header  |  1995-04-20  |  53KB  |  1,850 lines
  1. /* 
  2.  * tkSend.c --
  3.  *
  4.  *    This file provides procedures that implement the "send"
  5.  *    command, allowing commands to be passed from interpreter
  6.  *    to interpreter.
  7.  *
  8.  * Copyright (c) 1989-1994 The Regents of the University of California.
  9.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  */
  14.  
  15. static char sccsid[] = "@(#) tkSend.c 1.48 95/04/20 16:26:59";
  16.  
  17. #include "tkPort.h"
  18. #include "tkInt.h"
  19.  
  20. /* 
  21.  * The following structure is used to keep track of the interpreters
  22.  * registered by this process.
  23.  */
  24.  
  25. typedef struct RegisteredInterp {
  26.     char *name;            /* Interpreter's name (malloc-ed). */
  27.     Tcl_Interp *interp;        /* Interpreter associated with name.  NULL
  28.                  * means that the application was unregistered
  29.                  * or deleted while a send was in progress
  30.                  * to it. */
  31.     TkDisplay *dispPtr;        /* Display for the application.  Needed
  32.                  * because we may need to unregister the
  33.                  * interpreter after its main window has
  34.                  * been deleted. */
  35.     struct RegisteredInterp *nextPtr;
  36.                 /* Next in list of names associated
  37.                  * with interps in this process.
  38.                  * NULL means end of list. */
  39. } RegisteredInterp;
  40.  
  41. static RegisteredInterp *registry = NULL;
  42.                 /* List of all interpreters
  43.                  * registered by this process. */
  44.  
  45. /*
  46.  * A registry of all interpreters for a display is kept in a
  47.  * property "InterpRegistry" on the root window of the display.
  48.  * It is organized as a series of zero or more concatenated strings
  49.  * (in no particular order), each of the form
  50.  *     window space name '\0'
  51.  * where "window" is the hex id of the comm. window to use to talk
  52.  * to an interpreter named "name".
  53.  *
  54.  * When the registry is being manipulated by an application (e.g. to
  55.  * add or remove an entry), it is loaded into memory using a structure
  56.  * of the following type:
  57.  */
  58.  
  59. typedef struct NameRegistry {
  60.     TkDisplay *dispPtr;        /* Display from which the registry was
  61.                  * read. */
  62.     int locked;            /* Non-zero means that the display was
  63.                  * locked when the property was read in. */
  64.     int modified;        /* Non-zero means that the property has
  65.                  * been modified, so it needs to be written
  66.                  * out when the NameRegistry is closed. */
  67.     unsigned long propLength;    /* Length of the property, in bytes. */
  68.     char *property;        /* The contents of the property.  See format
  69.                  * above;  this is *not* terminated by the
  70.                  * first null character.  Dynamically
  71.                  * allocated. */
  72.     int allocedByX;        /* Non-zero means must free property with
  73.                  * XFree;  zero means use ckfree. */
  74. } NameRegistry;
  75.  
  76. /*
  77.  * When a result is being awaited from a sent command, one of
  78.  * the following structures is present on a list of all outstanding
  79.  * sent commands.  The information in the structure is used to
  80.  * process the result when it arrives.  You're probably wondering
  81.  * how there could ever be multiple outstanding sent commands.
  82.  * This could happen if interpreters invoke each other recursively.
  83.  * It's unlikely, but possible.
  84.  */
  85.  
  86. typedef struct PendingCommand {
  87.     int serial;            /* Serial number expected in
  88.                  * result. */
  89.     TkDisplay *dispPtr;        /* Display being used for communication. */
  90.     char *target;        /* Name of interpreter command is
  91.                  * being sent to. */
  92.     Window commWindow;        /* Target's communication window. */
  93.     Tk_TimerToken timeout;    /* Token for timer handler used to check
  94.                  * up on target during long sends. */
  95.     Tcl_Interp *interp;        /* Interpreter from which the send
  96.                  * was invoked. */
  97.     int code;            /* Tcl return code for command
  98.                  * will be stored here. */
  99.     char *result;        /* String result for command (malloc'ed),
  100.                  * or NULL. */
  101.     char *errorInfo;        /* Information for "errorInfo" variable,
  102.                  * or NULL (malloc'ed). */
  103.     char *errorCode;        /* Information for "errorCode" variable,
  104.                  * or NULL (malloc'ed). */
  105.     int gotResponse;        /* 1 means a response has been received,
  106.                  * 0 means the command is still outstanding. */
  107.     struct PendingCommand *nextPtr;
  108.                 /* Next in list of all outstanding
  109.                  * commands.  NULL means end of
  110.                  * list. */
  111. } PendingCommand;
  112.  
  113. static PendingCommand *pendingCommands = NULL;
  114.                 /* List of all commands currently
  115.                  * being waited for. */
  116.  
  117. /*
  118.  * The information below is used for communication between processes
  119.  * during "send" commands.  Each process keeps a private window, never
  120.  * even mapped, with one property, "Comm".  When a command is sent to
  121.  * an interpreter, the command is appended to the comm property of the
  122.  * communication window associated with the interp's process.  Similarly,
  123.  * when a result is returned from a sent command, it is also appended
  124.  * to the comm property.
  125.  *
  126.  * Each command and each result takes the form of ASCII text.  For a
  127.  * command, the text consists of a zero character followed by several
  128.  * null-terminated ASCII strings.  The first string consists of the
  129.  * single letter "c".  Subsequent strings have the form "option value"
  130.  * where the following options are supported:
  131.  *
  132.  * -r commWindow serial
  133.  *
  134.  *    This option means that a response should be sent to the window
  135.  *    whose X identifier is "commWindow" (in hex), and the response should
  136.  *    be identified with the serial number given by "serial" (in decimal).
  137.  *    If this option isn't specified then the send is asynchronous and
  138.  *    no response is sent.
  139.  *
  140.  * -n name
  141.  *    "Name" gives the name of the application for which the command is
  142.  *    intended.  This option must be present.
  143.  *
  144.  * -s script
  145.  *
  146.  *    "Script" is the script to be executed.  This option must be present.
  147.  *
  148.  * The options may appear in any order.  The -n and -s options must be
  149.  * present, but -r may be omitted for asynchronous RPCs.  For compatibility
  150.  * with future releases that may add new features, there may be additional
  151.  * options present;  as long as they start with a "-" character, they will
  152.  * be ignored.
  153.  *
  154.  * A result also consists of a zero character followed by several null-
  155.  * terminated ASCII strings.  The first string consists of the single
  156.  * letter "r".  Subsequent strings have the form "option value" where
  157.  * the following options are supported:
  158.  *
  159.  * -s serial
  160.  *
  161.  *    Identifies the command for which this is the result.  It is the
  162.  *    same as the "serial" field from the -s option in the command.  This
  163.  *    option must be present.
  164.  *
  165.  * -c code
  166.  *
  167.  *    "Code" is the completion code for the script, in decimal.  If the
  168.  *    code is omitted it defaults to TCL_OK.
  169.  *
  170.  * -r result
  171.  *
  172.  *    "Result" is the result string for the script, which may be either
  173.  *    a result or an error message.  If this field is omitted then it
  174.  *    defaults to an empty string.
  175.  *
  176.  * -i errorInfo
  177.  *
  178.  *    "ErrorInfo" gives a string with which to initialize the errorInfo
  179.  *    variable.  This option may be omitted;  it is ignored unless the
  180.  *    completion code is TCL_ERROR.
  181.  *
  182.  * -e errorCode
  183.  *
  184.  *    "ErrorCode" gives a string with with to initialize the errorCode
  185.  *    variable.  This option may be omitted;  it is ignored  unless the
  186.  *    completion code is TCL_ERROR.
  187.  *
  188.  * Options may appear in any order, and only the -s option must be
  189.  * present.  As with commands, there may be additional options besides
  190.  * these;  unknown options are ignored.
  191.  */
  192.  
  193. /*
  194.  * The following variable is the serial number that was used in the
  195.  * last "send" command.  It is exported only for testing purposes.
  196.  */
  197.  
  198. int tkSendSerial = 0;
  199.  
  200. /*
  201.  * Maximum size property that can be read at one time by
  202.  * this module:
  203.  */
  204.  
  205. #define MAX_PROP_WORDS 100000
  206.  
  207. /*
  208.  * The following variable can be set while debugging to do things like
  209.  * skip locking the server.
  210.  */
  211.  
  212. static int sendDebug = 0;
  213.  
  214. /*
  215.  * Forward declarations for procedures defined later in this file:
  216.  */
  217.  
  218. static int        AppendErrorProc _ANSI_ARGS_((ClientData clientData,
  219.                 XErrorEvent *errorPtr));
  220. static void        AppendPropCarefully _ANSI_ARGS_((Display *display,
  221.                 Window window, Atom property, char *value,
  222.                 int length, PendingCommand *pendingPtr));
  223. static void        DeleteProc _ANSI_ARGS_((ClientData clientData));
  224. static void        RegAddName _ANSI_ARGS_((NameRegistry *regPtr,
  225.                 char *name, Window commWindow));
  226. static void        RegClose _ANSI_ARGS_((NameRegistry *regPtr));
  227. static void        RegDeleteName _ANSI_ARGS_((NameRegistry *regPtr,
  228.                 char *name));
  229. static Window        RegFindName _ANSI_ARGS_((NameRegistry *regPtr,
  230.                 char *name));
  231. static NameRegistry *    RegOpen _ANSI_ARGS_((Tcl_Interp *interp,
  232.                 TkDisplay *dispPtr, int lock));
  233. static void        SendEventProc _ANSI_ARGS_((ClientData clientData,
  234.                 XEvent *eventPtr));
  235. static int        SendInit _ANSI_ARGS_((Tcl_Interp *interp,
  236.                 TkDisplay *dispPtr));
  237. static Bool        SendRestrictProc _ANSI_ARGS_((Display *display,
  238.                 XEvent *eventPtr, char *arg));
  239. static int        ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr));
  240. static void        TimeoutProc _ANSI_ARGS_((ClientData clientData));
  241. static void        UpdateCommWindow _ANSI_ARGS_((TkDisplay *dispPtr));
  242. static int        ValidateName _ANSI_ARGS_((TkDisplay *dispPtr,
  243.                 char *name, Window commWindow, int oldOK));
  244.  
  245. /*
  246.  *----------------------------------------------------------------------
  247.  *
  248.  * RegOpen --
  249.  *
  250.  *    This procedure loads the name registry for a display into
  251.  *    memory so that it can be manipulated.
  252.  *
  253.  * Results:
  254.  *    The return value is a pointer to the loaded registry.
  255.  *
  256.  * Side effects:
  257.  *    If "lock" is set then the server will be locked.  It is the
  258.  *    caller's responsibility to call RegClose when finished with
  259.  *    the registry, so that we can write back the registry if
  260.  *    neeeded, unlock the server if needed, and free memory.
  261.  *
  262.  *----------------------------------------------------------------------
  263.  */
  264.  
  265. static NameRegistry *
  266. RegOpen(interp, dispPtr, lock)
  267.     Tcl_Interp *interp;        /* Interpreter to use for error reporting
  268.                  * (errors cause a panic so in fact no
  269.                  * error is ever returned, but the interpreter
  270.                  * is needed anyway). */
  271.     TkDisplay *dispPtr;        /* Display whose name registry is to be
  272.                  * opened. */
  273.     int lock;            /* Non-zero means lock the window server
  274.                  * when opening the registry, so no-one
  275.                  * else can use the registry until we
  276.                  * close it. */
  277. {
  278.     NameRegistry *regPtr;
  279.     int result, actualFormat;
  280.     unsigned long bytesAfter;
  281.     Atom actualType;
  282.  
  283.     if (dispPtr->commTkwin == NULL) {
  284.     SendInit(interp, dispPtr);
  285.     }
  286.  
  287.     regPtr = (NameRegistry *) ckalloc(sizeof(NameRegistry));
  288.     regPtr->dispPtr = dispPtr;
  289.     regPtr->locked = 0;
  290.     regPtr->modified = 0;
  291.     regPtr->allocedByX = 1;
  292.  
  293.     if (lock && !sendDebug) {
  294.     XGrabServer(dispPtr->display);
  295.     regPtr->locked = 1;
  296.     }
  297.  
  298.     /*
  299.      * Read the registry property.
  300.      */
  301.  
  302.     result = XGetWindowProperty(dispPtr->display,
  303.         RootWindow(dispPtr->display, 0),
  304.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  305.         False, XA_STRING, &actualType, &actualFormat,
  306.         ®Ptr->propLength, &bytesAfter,
  307.         (unsigned char **) ®Ptr->property);
  308.  
  309.     if (actualType == None) {
  310.     regPtr->propLength = 0;
  311.     regPtr->property = NULL;
  312.     } else if ((result != Success) || (actualFormat != 8)
  313.         || (actualType != XA_STRING)) {
  314.     /*
  315.      * The property is improperly formed;  delete it.
  316.      */
  317.  
  318.     if (regPtr->property != NULL) {
  319.         XFree(regPtr->property);
  320.         regPtr->propLength = 0;
  321.         regPtr->property = NULL;
  322.     }
  323.     XDeleteProperty(dispPtr->display,
  324.         RootWindow(dispPtr->display, 0),
  325.         dispPtr->registryProperty);
  326.     }
  327.  
  328.     /*
  329.      * Xlib placed an extra null byte after the end of the property, just
  330.      * to make sure that it is always NULL-terminated.  Be sure to include
  331.      * this byte in our count if it's needed to ensure null termination.
  332.      */
  333.  
  334.     if ((regPtr->propLength > 0)
  335.         && (regPtr->property[regPtr->propLength-1] != 0)) {
  336.     regPtr->propLength++;
  337.     }
  338.     return regPtr;
  339. }
  340.  
  341. /*
  342.  *----------------------------------------------------------------------
  343.  *
  344.  * RegFindName --
  345.  *
  346.  *    Given an open name registry, this procedure finds an entry
  347.  *    with a given name, if there is one, and returns information
  348.  *    about that entry.
  349.  *
  350.  * Results:
  351.  *    The return value is the X identifier for the comm window for
  352.  *    the application named "name", or None if there is no such
  353.  *    entry in the registry.
  354.  *
  355.  * Side effects:
  356.  *    None.
  357.  *
  358.  *----------------------------------------------------------------------
  359.  */
  360.  
  361. static Window
  362. RegFindName(regPtr, name)
  363.     NameRegistry *regPtr;    /* Pointer to a registry opened with a
  364.                  * previous call to RegOpen. */
  365.     char *name;            /* Name of an application. */
  366. {
  367.     char *p, *entry;
  368.     Window commWindow;
  369.  
  370.     commWindow = None;
  371.     for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) {
  372.     entry = p;
  373.     while ((*p != 0) && (!isspace(UCHAR(*p)))) {
  374.         p++;
  375.     }
  376.     if ((*p != 0) && (strcmp(name, p+1) == 0)) {
  377.         if (sscanf(entry, "%x", (unsigned int *) &commWindow) == 1) {
  378.         return commWindow;
  379.         }
  380.     }
  381.     while (*p != 0) {
  382.         p++;
  383.     }
  384.     p++;
  385.     }
  386.     return None;
  387. }
  388.  
  389. /*
  390.  *----------------------------------------------------------------------
  391.  *
  392.  * RegDeleteName --
  393.  *
  394.  *    This procedure deletes the entry for a given name from
  395.  *    an open registry.
  396.  *
  397.  * Results:
  398.  *    None.
  399.  *
  400.  * Side effects:
  401.  *    If there used to be an entry named "name" in the registry,
  402.  *    then it is deleted and the registry is marked as modified
  403.  *    so it will be written back when closed.
  404.  *
  405.  *----------------------------------------------------------------------
  406.  */
  407.  
  408. static void
  409. RegDeleteName(regPtr, name)
  410.     NameRegistry *regPtr;    /* Pointer to a registry opened with a
  411.                  * previous call to RegOpen. */
  412.     char *name;            /* Name of an application. */
  413. {
  414.     char *p, *entry, *entryName;
  415.     int count;
  416.  
  417.     for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) {
  418.     entry = p;
  419.     while ((*p != 0) && (!isspace(UCHAR(*p)))) {
  420.         p++;
  421.     }
  422.     if (*p != 0) {
  423.         p++;
  424.     }
  425.     entryName = p;
  426.     while (*p != 0) {
  427.         p++;
  428.     }
  429.     p++;
  430.     if ((strcmp(name, entryName) == 0)) {
  431.         /*
  432.          * Found the matching entry.  Copy everything after it
  433.          * down on top of it.
  434.          */
  435.  
  436.         count = regPtr->propLength - (p - regPtr->property);
  437.         if (count > 0)  {
  438.         memmove((VOID *) entry, (VOID *) p, (size_t) count);
  439.         }
  440.         regPtr->propLength -=  p - entry;
  441.         regPtr->modified = 1;
  442.         return;
  443.     }
  444.     }
  445. }
  446.  
  447. /*
  448.  *----------------------------------------------------------------------
  449.  *
  450.  * RegAddName --
  451.  *
  452.  *    Add a new entry to an open registry.
  453.  *
  454.  * Results:
  455.  *    None.
  456.  *
  457.  * Side effects:
  458.  *    The open registry is exapanded;  it is marked as modified so that
  459.  *    it will be written back when closed.
  460.  *
  461.  *----------------------------------------------------------------------
  462.  */
  463.  
  464. static void
  465. RegAddName(regPtr, name, commWindow)
  466.     NameRegistry *regPtr;    /* Pointer to a registry opened with a
  467.                  * previous call to RegOpen. */
  468.     char *name;            /* Name of an application.  The caller
  469.                  * must ensure that this name isn't
  470.                  * already registered. */
  471.     Window commWindow;        /* X identifier for comm. window of
  472.                  * application.  */
  473. {
  474.     char id[30];
  475.     char *newProp;
  476.     int idLength, newBytes;
  477.  
  478.     sprintf(id, "%x ", (unsigned int) commWindow);
  479.     idLength = strlen(id);
  480.     newBytes = idLength + strlen(name) + 1;
  481.     newProp = (char *) ckalloc((unsigned) (regPtr->propLength + newBytes));
  482.     strcpy(newProp, id);
  483.     strcpy(newProp+idLength, name);
  484.     if (regPtr->propLength > 0) {
  485.     memcpy((VOID *) (newProp + newBytes), (VOID *) regPtr->property,
  486.         regPtr->propLength);
  487.     if (regPtr->allocedByX) {
  488.         XFree(regPtr->property);
  489.     } else {
  490.         ckfree(regPtr->property);
  491.     }
  492.     }
  493.     regPtr->modified = 1;
  494.     regPtr->propLength += newBytes;
  495.     regPtr->property = newProp;
  496.     regPtr->allocedByX = 0;
  497. }
  498.  
  499. /*
  500.  *----------------------------------------------------------------------
  501.  *
  502.  * RegClose --
  503.  *
  504.  *    This procedure is called to end a series of operations on
  505.  *    a name registry.
  506.  *
  507.  * Results:
  508.  *    None.
  509.  *
  510.  * Side effects:
  511.  *    The registry is written back if it has been modified, and the
  512.  *    X server is unlocked if it was locked.  Memory for the
  513.  *    registry is freed, so the caller should never use regPtr
  514.  *    again.
  515.  *
  516.  *----------------------------------------------------------------------
  517.  */
  518.  
  519. static void
  520. RegClose(regPtr)
  521.     NameRegistry *regPtr;    /* Pointer to a registry opened with a
  522.                  * previous call to RegOpen. */
  523. {
  524.     if (regPtr->modified) {
  525.     if (!regPtr->locked && !sendDebug) {
  526.         panic("The name registry was modified without being locked!");
  527.     }
  528.     XChangeProperty(regPtr->dispPtr->display,
  529.         RootWindow(regPtr->dispPtr->display, 0),
  530.         regPtr->dispPtr->registryProperty, XA_STRING, 8,
  531.         PropModeReplace, (unsigned char *) regPtr->property,
  532.         (int) regPtr->propLength);
  533.     }
  534.  
  535.     if (regPtr->locked) {
  536.     XUngrabServer(regPtr->dispPtr->display);
  537.     }
  538.     XFlush(regPtr->dispPtr->display);
  539.  
  540.     if (regPtr->propLength > 0) {
  541.     if (regPtr->allocedByX) {
  542.         XFree(regPtr->property);
  543.     } else {
  544.         ckfree(regPtr->property);
  545.     }
  546.     }
  547.     ckfree((char *) regPtr);
  548. }
  549.  
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * ValidateName --
  554.  *
  555.  *    This procedure checks to see if an entry in the registry
  556.  *    is still valid.
  557.  *
  558.  * Results:
  559.  *    The return value is 1 if the given commWindow exists and its
  560.  *    name is "name".  Otherwise 0 is returned.
  561.  *
  562.  * Side effects:
  563.  *    None.
  564.  *
  565.  *----------------------------------------------------------------------
  566.  */
  567.  
  568. static int
  569. ValidateName(dispPtr, name, commWindow, oldOK)
  570.     TkDisplay *dispPtr;        /* Display for which to perform the
  571.                  * validation. */
  572.     char *name;            /* The name of an application. */
  573.     Window commWindow;        /* X identifier for the application's
  574.                  * comm. window. */
  575.     int oldOK;            /* Non-zero means that we should consider
  576.                  * an application to be valid even if it
  577.                  * looks like an old-style (pre-4.0) one;
  578.                  * 0 means consider these invalid. */
  579. {
  580.     int result, actualFormat, argc, i;
  581.     unsigned long length, bytesAfter;
  582.     Atom actualType;
  583.     char *property;
  584.     Tk_ErrorHandler handler;
  585.     char **argv;
  586.  
  587.     property = NULL;
  588.  
  589.     /*
  590.      * Ignore X errors when reading the property (e.g., the window
  591.      * might not exist).  If an error occurs, result will be some
  592.      * value other than Success.
  593.      */
  594.  
  595.     handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1,
  596.         (Tk_ErrorProc *) NULL, (ClientData) NULL);
  597.     result = XGetWindowProperty(dispPtr->display, commWindow,
  598.         dispPtr->appNameProperty, 0, MAX_PROP_WORDS,
  599.         False, XA_STRING, &actualType, &actualFormat,
  600.         &length, &bytesAfter, (unsigned char **) &property);
  601.  
  602.     if ((result == Success) && (actualType == None)) {
  603.     XWindowAttributes atts;
  604.  
  605.     /*
  606.      * The comm. window exists but the property we're looking for
  607.      * doesn't exist.  This probably means that the application
  608.      * comes from an older version of Tk (< 4.0) that didn't set the
  609.      * property;  if this is the case, then assume for compatibility's
  610.      * sake that everything's OK.  However, it's also possible that
  611.      * some random application has re-used the window id for something
  612.      * totally unrelated.  Check a few characteristics of the window,
  613.      * such as its dimensions and mapped state, to be sure that it
  614.      * still "smells" like a commWindow.
  615.      */
  616.  
  617.     if (!oldOK
  618.         || !XGetWindowAttributes(dispPtr->display, commWindow, &atts)
  619.         || (atts.width != 1) || (atts.height != 1)
  620.         || (atts.map_state != IsUnmapped)) {
  621.         result = 0;
  622.     } else {
  623.         result = 1;
  624.     }
  625.     } else if ((result == Success) && (actualFormat == 8)
  626.        && (actualType == XA_STRING)) {
  627.     result = 0;
  628.     if (Tcl_SplitList((Tcl_Interp *) NULL, property, &argc, &argv)
  629.         == TCL_OK) {
  630.         for (i = 0; i < argc; i++) {
  631.         if (strcmp(argv[i], name) == 0) {
  632.             result = 1;
  633.             break;
  634.         }
  635.         }
  636.         ckfree((char *) argv);
  637.     }
  638.     } else {
  639.        result = 0;
  640.     }
  641.     Tk_DeleteErrorHandler(handler);
  642.     if (property != NULL) {
  643.     XFree(property);
  644.     }
  645.     return result;
  646. }
  647.  
  648. /*
  649.  *----------------------------------------------------------------------
  650.  *
  651.  * ServerSecure --
  652.  *
  653.  *    Check whether a server is secure enough for us to trust
  654.  *    Tcl scripts arriving via that server.
  655.  *
  656.  * Results:
  657.  *    The return value is 1 if the server is secure, which means
  658.  *    that host-style authentication is turned on but there are
  659.  *    no hosts in the enabled list.  This means that some other
  660.  *    form of authorization (presumably more secure, such as xauth)
  661.  *    is in use.
  662.  *
  663.  * Side effects:
  664.  *    None.
  665.  *
  666.  *----------------------------------------------------------------------
  667.  */
  668.  
  669. static int
  670. ServerSecure(dispPtr)
  671.     TkDisplay *dispPtr;        /* Display to check. */
  672. {
  673. #ifdef TK_NO_SECURITY
  674.     return 1;
  675. #else
  676.     XHostAddress *addrPtr;
  677.     int numHosts, secure;
  678.     Bool enabled;
  679.  
  680.     secure = 0;
  681.     addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled);
  682.     if (enabled && (numHosts == 0)) {
  683.     secure = 1;
  684.     }
  685.     if (addrPtr != NULL) {
  686.     XFree((char *) addrPtr);
  687.     }
  688.     return secure;
  689. #endif /* TK_NO_SECURITY */
  690. }
  691.  
  692. /*
  693.  *--------------------------------------------------------------
  694.  *
  695.  * Tk_SetAppName --
  696.  *
  697.  *    This procedure is called to associate an ASCII name with a Tk
  698.  *    application.  If the application has already been named, the
  699.  *    name replaces the old one.
  700.  *
  701.  * Results:
  702.  *    The return value is the name actually given to the application.
  703.  *    This will normally be the same as name, but if name was already
  704.  *    in use for an application then a name of the form "name #2" will
  705.  *    be chosen,  with a high enough number to make the name unique.
  706.  *
  707.  * Side effects:
  708.  *    Registration info is saved, thereby allowing the "send" command
  709.  *    to be used later to invoke commands in the application.  In
  710.  *    addition, the "send" command is created in the application's
  711.  *    interpreter.  The registration will be removed automatically
  712.  *    if the interpreter is deleted or the "send" command is removed.
  713.  *
  714.  *--------------------------------------------------------------
  715.  */
  716.  
  717. char *
  718. Tk_SetAppName(tkwin, name)
  719.     Tk_Window tkwin;        /* Token for any window in the application
  720.                  * to be named:  it is just used to identify
  721.                  * the application and the display.  */
  722.     char *name;            /* The name that will be used to
  723.                  * refer to the interpreter in later
  724.                  * "send" commands.  Must be globally
  725.                  * unique. */
  726. {
  727.     RegisteredInterp *riPtr;
  728.     Window w;
  729.     TkWindow *winPtr = (TkWindow *) tkwin;
  730.     TkDisplay *dispPtr;
  731.     NameRegistry *regPtr;
  732.     Tcl_Interp *interp;
  733.     char *actualName;
  734.     Tcl_DString dString;
  735.     int offset, i;
  736.  
  737.     dispPtr = winPtr->dispPtr;
  738.     interp = winPtr->mainPtr->interp;
  739.     if (dispPtr->commTkwin == NULL) {
  740.     SendInit(interp, winPtr->dispPtr);
  741.     }
  742.  
  743.     /*
  744.      * See if the application is already registered;  if so, remove its
  745.      * current name from the registry.
  746.      */
  747.  
  748.     regPtr = RegOpen(interp, winPtr->dispPtr, 1);
  749.     for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
  750.     if (riPtr == NULL) {
  751.         /*
  752.          * This interpreter isn't currently registered;  create
  753.          * the data structure that will be used to register it locally,
  754.          * plus add the "send" command to the interpreter.
  755.          */
  756.  
  757.         riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
  758.         riPtr->interp = interp;
  759.         riPtr->dispPtr = winPtr->dispPtr;
  760.         riPtr->nextPtr = registry;
  761.         registry = riPtr;
  762.         Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) riPtr,
  763.             DeleteProc);
  764.         break;
  765.     }
  766.     if (riPtr->interp == interp) {
  767.         /*
  768.          * The interpreter is currently registered;  remove it from
  769.          * the name registry.
  770.          */
  771.  
  772.         RegDeleteName(regPtr, riPtr->name);
  773.         ckfree(riPtr->name);
  774.         break;
  775.     }
  776.     }
  777.  
  778.     /*
  779.      * Pick a name to use for the application.  Use "name" if it's not
  780.      * already in use,
  781.      */
  782.  
  783.     actualName = name;
  784.     w = RegFindName(regPtr, actualName);
  785.     if (w == None) {
  786.     goto gotName;
  787.     }
  788.  
  789.     /*
  790.      * The name appears to be in use already.  Check to be sure
  791.      * that it really is in use by someone other than us (perhaps
  792.      * the application died without removing its name from the
  793.      * registry?).
  794.      */
  795.  
  796.     if ((w == Tk_WindowId(dispPtr->commTkwin))
  797.         || !ValidateName(winPtr->dispPtr, actualName, w, 1)) {
  798.     RegDeleteName(regPtr, actualName);
  799.     goto gotName;
  800.     }
  801.  
  802.     /*
  803.      * Start with the suffix " #2" and increment the number until one
  804.      * eventually works.
  805.      */
  806.  
  807.     Tcl_DStringInit(&dString);
  808.     Tcl_DStringAppend(&dString, name, -1);
  809.     Tcl_DStringAppend(&dString, " #", 2);
  810.     offset = Tcl_DStringLength(&dString);
  811.     Tcl_DStringSetLength(&dString, offset+10);
  812.     actualName = Tcl_DStringValue(&dString);
  813.     for (i = 2; ; i++) {
  814.     sprintf(actualName + offset, "%d", i);
  815.     w = RegFindName(regPtr, actualName);
  816.     if (w == None) {
  817.         break;
  818.     }
  819.     if ((w == Tk_WindowId(dispPtr->commTkwin))
  820.         || !ValidateName(dispPtr, actualName, w, 1)) {
  821.         RegDeleteName(regPtr, actualName);
  822.         break;
  823.     }
  824.     }
  825.  
  826.     /*
  827.      * We've now got a name to use.  Store it in the name registry and
  828.      * in the local entry for this application, plus put it in a property
  829.      * on the commWindow.
  830.      */
  831.  
  832.     gotName:
  833.     RegAddName(regPtr, actualName, Tk_WindowId(dispPtr->commTkwin));
  834.     RegClose(regPtr);
  835.     riPtr->name = (char *) ckalloc((unsigned) (strlen(actualName) + 1));
  836.     strcpy(riPtr->name, actualName);
  837.     if (actualName != name) {
  838.     Tcl_DStringFree(&dString);
  839.     }
  840.     UpdateCommWindow(dispPtr);
  841.  
  842.     return riPtr->name;
  843. }
  844.  
  845. /*
  846.  *--------------------------------------------------------------
  847.  *
  848.  * Tk_SendCmd --
  849.  *
  850.  *    This procedure is invoked to process the "send" Tcl command.
  851.  *    See the user documentation for details on what it does.
  852.  *
  853.  * Results:
  854.  *    A standard Tcl result.
  855.  *
  856.  * Side effects:
  857.  *    See the user documentation.
  858.  *
  859.  *--------------------------------------------------------------
  860.  */
  861.  
  862. int
  863. Tk_SendCmd(clientData, interp, argc, argv)
  864.     ClientData clientData;        /* Information about sender (only
  865.                      * dispPtr field is used). */
  866.     Tcl_Interp *interp;            /* Current interpreter. */
  867.     int argc;                /* Number of arguments. */
  868.     char **argv;            /* Argument strings. */
  869. {
  870.     TkWindow *winPtr;
  871.     Window commWindow;
  872.     PendingCommand pending;
  873.     register RegisteredInterp *riPtr;
  874.     char *destName, buffer[30];
  875.     int result, c, async, i, firstArg;
  876.     size_t length;
  877.     Bool (*prevRestrictProc)();
  878.     char *prevArg;
  879.     TkDisplay *dispPtr;
  880.     NameRegistry *regPtr;
  881.     Tcl_DString request;
  882.  
  883.     /*
  884.      * Process options, if any.
  885.      */
  886.  
  887.     async = 0;
  888.     winPtr = (TkWindow *) Tk_MainWindow(interp);
  889.     if (winPtr == NULL) {
  890.     return TCL_ERROR;
  891.     }
  892.     for (i = 1; i < (argc-1); ) {
  893.     if (argv[i][0] != '-') {
  894.         break;
  895.     }
  896.     c = argv[i][1];
  897.     length = strlen(argv[i]);
  898.     if ((c == 'a') && (strncmp(argv[i], "-async", length) == 0)) {
  899.         async = 1;
  900.         i++;
  901.     } else if ((c == 'd') && (strncmp(argv[i], "-displayof",
  902.         length) == 0)) {
  903.         winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[i+1],
  904.             (Tk_Window) winPtr);
  905.         if (winPtr == NULL) {
  906.         return TCL_ERROR;
  907.         }
  908.         i += 2;
  909.     } else if (strcmp(argv[i], "--") == 0) {
  910.         i++;
  911.         break;
  912.     } else {
  913.         Tcl_AppendResult(interp, "bad option \"", argv[i],
  914.             "\": must be -async, -displayof, or --", (char *) NULL);
  915.         return TCL_ERROR;
  916.     }
  917.     }
  918.  
  919.     if (argc < (i+2)) {
  920.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  921.         " ?options? interpName arg ?arg ...?\"", (char *) NULL);
  922.     return TCL_ERROR;
  923.     }
  924.     destName = argv[i];
  925.     firstArg = i+1;
  926.  
  927.     dispPtr = winPtr->dispPtr;
  928.     if (dispPtr->commTkwin == NULL) {
  929.     SendInit(interp, winPtr->dispPtr);
  930.     }
  931.  
  932.     /*
  933.      * See if the target interpreter is local.  If so, execute
  934.      * the command directly without going through the X server.
  935.      * The only tricky thing is passing the result from the target
  936.      * interpreter to the invoking interpreter.  Watch out:  they
  937.      * could be the same!
  938.      */
  939.  
  940.     for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
  941.     if ((riPtr->dispPtr != dispPtr)
  942.         || (strcmp(riPtr->name, destName) != 0)) {
  943.         continue;
  944.     }
  945.     Tk_Preserve((ClientData) riPtr);
  946.     if (firstArg == (argc-1)) {
  947.         result = Tcl_GlobalEval(riPtr->interp, argv[firstArg]);
  948.     } else {
  949.         Tcl_DStringInit(&request);
  950.         Tcl_DStringAppend(&request, argv[firstArg], -1);
  951.         for (i = firstArg+1; i < argc; i++) {
  952.         Tcl_DStringAppend(&request, " ", 1);
  953.         Tcl_DStringAppend(&request, argv[i], -1);
  954.         }
  955.         result = Tcl_GlobalEval(riPtr->interp, Tcl_DStringValue(&request));
  956.         Tcl_DStringFree(&request);
  957.     }
  958.     if ((riPtr->interp != NULL) && (interp != riPtr->interp)) {
  959.         if (result == TCL_ERROR) {
  960.         /*
  961.          * An error occurred, so transfer error information from the
  962.          * destination interpreter back to our interpreter.  Must clear
  963.          * interp's result before calling Tcl_AddErrorInfo, since
  964.          * Tcl_AddErrorInfo will store the interp's result in errorInfo
  965.          * before appending riPtr's $errorInfo;  we've already got
  966.          * everything we need in riPtr's $errorInfo.
  967.          */
  968.  
  969.         Tcl_ResetResult(interp);
  970.         Tcl_AddErrorInfo(interp, Tcl_GetVar2(riPtr->interp,
  971.             "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
  972.         Tcl_SetVar2(interp, "errorCode", (char *) NULL,
  973.             Tcl_GetVar2(riPtr->interp, "errorCode", (char *) NULL,
  974.             TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);
  975.         }
  976.         if (riPtr->interp->freeProc != NULL) {
  977.         interp->result = riPtr->interp->result;
  978.         interp->freeProc = riPtr->interp->freeProc;
  979.         riPtr->interp->freeProc = 0;
  980.         } else {
  981.         Tcl_SetResult(interp, riPtr->interp->result, TCL_VOLATILE);
  982.         }
  983.         Tcl_ResetResult(riPtr->interp);
  984.     }
  985.     Tk_Release((ClientData) riPtr);
  986.     return result;
  987.     }
  988.  
  989.     /*
  990.      * Bind the interpreter name to a communication window.
  991.      */
  992.  
  993.     regPtr = RegOpen(interp, winPtr->dispPtr, 0);
  994.     commWindow = RegFindName(regPtr, destName);
  995.     RegClose(regPtr);
  996.     if (commWindow == None) {
  997.     Tcl_AppendResult(interp, "no application named \"",
  998.         destName, "\"", (char *) NULL);
  999.     return TCL_ERROR;
  1000.     }
  1001.  
  1002.     /*
  1003.      * Send the command to the target interpreter by appending it to the
  1004.      * comm window in the communication window.
  1005.      */
  1006.  
  1007.     tkSendSerial++;
  1008.     Tcl_DStringInit(&request);
  1009.     Tcl_DStringAppend(&request, "\0c\0-n ", 6);
  1010.     Tcl_DStringAppend(&request, destName, -1);
  1011.     if (!async) {
  1012.     sprintf(buffer, "%x %d",
  1013.         (unsigned int) Tk_WindowId(dispPtr->commTkwin),
  1014.         tkSendSerial);
  1015.     Tcl_DStringAppend(&request, "\0-r ", 4);
  1016.     Tcl_DStringAppend(&request, buffer, -1);
  1017.     }
  1018.     Tcl_DStringAppend(&request, "\0-s ", 4);
  1019.     Tcl_DStringAppend(&request, argv[firstArg], -1);
  1020.     for (i = firstArg+1; i < argc; i++) {
  1021.     Tcl_DStringAppend(&request, " ", 1);
  1022.     Tcl_DStringAppend(&request, argv[i], -1);
  1023.     }
  1024.     (void) AppendPropCarefully(dispPtr->display, commWindow,
  1025.         dispPtr->commProperty, Tcl_DStringValue(&request),
  1026.         Tcl_DStringLength(&request) + 1,
  1027.         (async) ? (PendingCommand *) NULL : &pending);
  1028.     Tcl_DStringFree(&request);
  1029.     if (async) {
  1030.     /*
  1031.      * This is an asynchronous send:  return immediately without
  1032.      * waiting for a response.
  1033.      */
  1034.  
  1035.     return TCL_OK;
  1036.     }
  1037.  
  1038.     /*
  1039.      * Register the fact that we're waiting for a command to complete
  1040.      * (this is needed by SendEventProc and by AppendErrorProc to pass
  1041.      * back the command's results).  Set up a timeout handler so that
  1042.      * we can check during long sends to make sure that the destination
  1043.      * application is still alive.
  1044.      */
  1045.  
  1046.     pending.serial = tkSendSerial;
  1047.     pending.dispPtr = dispPtr;
  1048.     pending.target = destName;
  1049.     pending.commWindow = commWindow;
  1050.     pending.timeout = Tk_CreateTimerHandler(1000, TimeoutProc,
  1051.         (ClientData) &pending);
  1052.     pending.interp = interp;
  1053.     pending.result = NULL;
  1054.     pending.errorInfo = NULL;
  1055.     pending.errorCode = NULL;
  1056.     pending.gotResponse = 0;
  1057.     pending.nextPtr = pendingCommands;
  1058.     pendingCommands = &pending;
  1059.  
  1060.     /*
  1061.      * Enter a loop processing X events until the result comes
  1062.      * in or the target is declared to be dead.  While waiting
  1063.      * for a result, look only at send-related events so that
  1064.      * the send is synchronous with respect to other events in
  1065.      * the application.
  1066.      */
  1067.  
  1068.     prevRestrictProc = Tk_RestrictEvents(SendRestrictProc,
  1069.         (char *) dispPtr->commTkwin, &prevArg);
  1070.     while (!pending.gotResponse) {
  1071.     Tk_DoOneEvent(TK_X_EVENTS|TK_TIMER_EVENTS);
  1072.     }
  1073.     Tk_DeleteTimerHandler(pending.timeout);
  1074.     (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg);
  1075.  
  1076.     /*
  1077.      * Unregister the information about the pending command
  1078.      * and return the result.
  1079.      */
  1080.  
  1081.     if (pendingCommands == &pending) {
  1082.     pendingCommands = pending.nextPtr;
  1083.     } else {
  1084.     PendingCommand *pcPtr;
  1085.  
  1086.     for (pcPtr = pendingCommands; pcPtr != NULL;
  1087.         pcPtr = pcPtr->nextPtr) {
  1088.         if (pcPtr->nextPtr == &pending) {
  1089.         pcPtr->nextPtr = pending.nextPtr;
  1090.         break;
  1091.         }
  1092.     }
  1093.     }
  1094.     if (pending.errorInfo != NULL) {
  1095.     /*
  1096.      * Special trick: must clear the interp's result before calling
  1097.      * Tcl_AddErrorInfo, since Tcl_AddErrorInfo will store the interp's
  1098.      * result in errorInfo before appending pending.errorInfo;  we've
  1099.      * already got everything we need in pending.errorInfo.
  1100.      */
  1101.  
  1102.     Tcl_ResetResult(interp);
  1103.     Tcl_AddErrorInfo(interp, pending.errorInfo);
  1104.     ckfree(pending.errorInfo);
  1105.     }
  1106.     if (pending.errorCode != NULL) {
  1107.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, pending.errorCode,
  1108.         TCL_GLOBAL_ONLY);
  1109.     ckfree(pending.errorCode);
  1110.     }
  1111.     Tcl_SetResult(interp, pending.result, TCL_DYNAMIC);
  1112.     return pending.code;
  1113. }
  1114.  
  1115. /*
  1116.  *----------------------------------------------------------------------
  1117.  *
  1118.  * TkGetInterpNames --
  1119.  *
  1120.  *    This procedure is invoked to fetch a list of all the
  1121.  *    interpreter names currently registered for the display
  1122.  *    of a particular window.
  1123.  *
  1124.  * Results:
  1125.  *    A standard Tcl return value.  Interp->result will be set
  1126.  *    to hold a list of all the interpreter names defined for
  1127.  *    tkwin's display.  If an error occurs, then TCL_ERROR
  1128.  *    is returned and interp->result will hold an error message.
  1129.  *
  1130.  * Side effects:
  1131.  *    None.
  1132.  *
  1133.  *----------------------------------------------------------------------
  1134.  */
  1135.  
  1136. int
  1137. TkGetInterpNames(interp, tkwin)
  1138.     Tcl_Interp *interp;        /* Interpreter for returning a result. */
  1139.     Tk_Window tkwin;        /* Window whose display is to be used
  1140.                  * for the lookup. */
  1141. {
  1142.     TkWindow *winPtr = (TkWindow *) tkwin;
  1143.     char *p, *entry, *entryName;
  1144.     NameRegistry *regPtr;
  1145.     Window commWindow;
  1146.     int count;
  1147.  
  1148.     /*
  1149.      * Read the registry property, then scan through all of its entries.
  1150.      * Validate each entry to be sure that its application still exists.
  1151.      */
  1152.  
  1153.     regPtr = RegOpen(interp, winPtr->dispPtr, 1);
  1154.     for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) {
  1155.     entry = p;
  1156.     if (sscanf(p,  "%x",(unsigned int *) &commWindow) != 1) {
  1157.         commWindow =  None;
  1158.     }
  1159.     while ((*p != 0) && (!isspace(UCHAR(*p)))) {
  1160.         p++;
  1161.     }
  1162.     if (*p != 0) {
  1163.         p++;
  1164.     }
  1165.     entryName = p;
  1166.     while (*p != 0) {
  1167.         p++;
  1168.     }
  1169.     p++;
  1170.     if (ValidateName(winPtr->dispPtr, entryName, commWindow, 1)) {
  1171.         /*
  1172.          * The application still exists; add its name to the result.
  1173.          */
  1174.  
  1175.         Tcl_AppendElement(interp, entryName);
  1176.     } else {
  1177.         /*
  1178.          * This name is bogus (perhaps the application died without
  1179.          * cleaning up its entry in the registry?).  Delete the name.
  1180.          */
  1181.  
  1182.         count = regPtr->propLength - (p - regPtr->property);
  1183.         if (count > 0)  {
  1184.         memmove((VOID *) entry, (VOID *) p, (size_t) count);
  1185.         }
  1186.         regPtr->propLength -= p - entry;
  1187.         regPtr->modified = 1;
  1188.         p = entry;
  1189.     }
  1190.     }
  1191.     RegClose(regPtr);
  1192.     return TCL_OK;
  1193. }
  1194.  
  1195. /*
  1196.  *--------------------------------------------------------------
  1197.  *
  1198.  * SendInit --
  1199.  *
  1200.  *    This procedure is called to initialize the
  1201.  *    communication channels for sending commands and
  1202.  *    receiving results.
  1203.  *
  1204.  * Results:
  1205.  *    None.
  1206.  *
  1207.  * Side effects:
  1208.  *    Sets up various data structures and windows.
  1209.  *
  1210.  *--------------------------------------------------------------
  1211.  */
  1212.  
  1213. static int
  1214. SendInit(interp, dispPtr)
  1215.     Tcl_Interp *interp;        /* Interpreter to use for error reporting
  1216.                  * (no errors are ever returned, but the
  1217.                  * interpreter is needed anyway). */
  1218.     TkDisplay *dispPtr;        /* Display to initialize. */
  1219. {
  1220.     TkMainInfo *mainPtr;
  1221.     TkWindow *winPtr;
  1222.     XSetWindowAttributes atts;
  1223.  
  1224.     /*
  1225.      * Create the window used for communication, and set up an
  1226.      * event handler for it.
  1227.      */
  1228.  
  1229.     dispPtr->commTkwin = Tk_CreateWindow(interp, (Tk_Window) NULL,
  1230.         "_comm", DisplayString(dispPtr->display));
  1231.     if (dispPtr->commTkwin == NULL) {
  1232.     panic("Tk_CreateWindow failed in SendInit!");
  1233.     }
  1234.     atts.override_redirect = True;
  1235.     Tk_ChangeWindowAttributes(dispPtr->commTkwin,
  1236.         CWOverrideRedirect, &atts);
  1237.     Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask,
  1238.         SendEventProc, (ClientData) dispPtr);
  1239.     Tk_MakeWindowExist(dispPtr->commTkwin);
  1240.  
  1241.     /*
  1242.      * Find a window on the display to use for registering property
  1243.      * names.
  1244.      */
  1245.  
  1246.     for (mainPtr = tkMainWindowList; ; mainPtr = mainPtr->nextPtr) {
  1247.     if (mainPtr == NULL) {
  1248.         return TCL_OK;
  1249.     }
  1250.     if (mainPtr->winPtr->dispPtr == dispPtr) {
  1251.         winPtr = mainPtr->winPtr;
  1252.         break;
  1253.     }
  1254.     }
  1255.  
  1256.     /*
  1257.      * Get atoms used as property names.
  1258.      */
  1259.  
  1260.     dispPtr->commProperty = Tk_InternAtom((Tk_Window) winPtr, "Comm");
  1261.     dispPtr->registryProperty = Tk_InternAtom((Tk_Window) winPtr,
  1262.         "InterpRegistry");
  1263.     dispPtr->appNameProperty = Tk_InternAtom((Tk_Window) winPtr,
  1264.         "TK_APPLICATION");
  1265.  
  1266.     return TCL_OK;
  1267. }
  1268.  
  1269. /*
  1270.  *--------------------------------------------------------------
  1271.  *
  1272.  * SendEventProc --
  1273.  *
  1274.  *    This procedure is invoked automatically by the toolkit
  1275.  *    event manager when a property changes on the communication
  1276.  *    window.  This procedure reads the property and handles
  1277.  *    command requests and responses.
  1278.  *
  1279.  * Results:
  1280.  *    None.
  1281.  *
  1282.  * Side effects:
  1283.  *    If there are command requests in the property, they
  1284.  *    are executed.  If there are responses in the property,
  1285.  *    their information is saved for the (ostensibly waiting)
  1286.  *    "send" commands. The property is deleted.
  1287.  *
  1288.  *--------------------------------------------------------------
  1289.  */
  1290.  
  1291. static void
  1292. SendEventProc(clientData, eventPtr)
  1293.     ClientData clientData;    /* Display information. */    
  1294.     XEvent *eventPtr;        /* Information about event. */
  1295. {
  1296.     TkDisplay *dispPtr = (TkDisplay *) clientData;
  1297.     char *propInfo;
  1298.     register char *p;
  1299.     int result, actualFormat;
  1300.     unsigned long numItems, bytesAfter;
  1301.     Atom actualType;
  1302.  
  1303.     if ((eventPtr->xproperty.atom != dispPtr->commProperty)
  1304.         || (eventPtr->xproperty.state != PropertyNewValue)) {
  1305.     return;
  1306.     }
  1307.  
  1308.     /*
  1309.      * Read the comm property and delete it.
  1310.      */
  1311.  
  1312.     propInfo = NULL;
  1313.     result = XGetWindowProperty(dispPtr->display,
  1314.         Tk_WindowId(dispPtr->commTkwin),
  1315.         dispPtr->commProperty, 0, MAX_PROP_WORDS, True,
  1316.         XA_STRING, &actualType, &actualFormat,
  1317.         &numItems, &bytesAfter, (unsigned char **) &propInfo);
  1318.  
  1319.     /*
  1320.      * If the property doesn't exist or is improperly formed
  1321.      * then ignore it.
  1322.      */
  1323.  
  1324.     if ((result != Success) || (actualType != XA_STRING)
  1325.         || (actualFormat != 8)) {
  1326.     if (propInfo != NULL) {
  1327.         XFree(propInfo);
  1328.     }
  1329.     return;
  1330.     }
  1331.  
  1332.     /*
  1333.      * Several commands and results could arrive in the property at
  1334.      * one time;  each iteration through the outer loop handles a
  1335.      * single command or result.
  1336.      */
  1337.  
  1338.     for (p = propInfo; (p-propInfo) < numItems; ) {
  1339.     /*
  1340.      * Ignore leading NULLs; each command or result starts with a
  1341.      * NULL so that no matter how badly formed a preceding command
  1342.      * is, we'll be able to tell that a new command/result is
  1343.      * starting.
  1344.      */
  1345.  
  1346.     if (*p == 0) {
  1347.         p++;
  1348.         continue;
  1349.     }
  1350.  
  1351.     if ((*p == 'c') && (p[1] == 0)) {
  1352.         Window commWindow;
  1353.         char *interpName, *script, *serial, *end;
  1354.         Tcl_DString reply;
  1355.         RegisteredInterp *riPtr;
  1356.  
  1357.         /*
  1358.          *----------------------------------------------------------
  1359.          * This is an incoming command from some other application.
  1360.          * Iterate over all of its options.  Stop when we reach
  1361.          * the end of the property or something that doesn't look
  1362.          * like an option.
  1363.          *----------------------------------------------------------
  1364.          */
  1365.  
  1366.         p += 2;
  1367.         interpName = NULL;
  1368.         commWindow = None;
  1369.         serial = "";
  1370.         script = NULL;
  1371.         while (((p-propInfo) < numItems) && (*p == '-')) {
  1372.         switch (p[1]) {
  1373.             case 'r':
  1374.             commWindow = (Window) strtoul(p+2, &end, 16);
  1375.             if ((end == p+2) || (*end != ' ')) {
  1376.                 commWindow = None;
  1377.             } else {
  1378.                 p = serial = end+1;
  1379.             }
  1380.             break;
  1381.             case 'n':
  1382.             if (p[2] == ' ') {
  1383.                 interpName = p+3;
  1384.             }
  1385.             break;
  1386.             case 's':
  1387.             if (p[2] == ' ') {
  1388.                 script = p+3;
  1389.             }
  1390.             break;
  1391.         }
  1392.         while (*p != 0) {
  1393.             p++;
  1394.         }
  1395.         p++;
  1396.         }
  1397.  
  1398.         if ((script == NULL) || (interpName == NULL)) {
  1399.         continue;
  1400.         }
  1401.  
  1402.         /*
  1403.          * Initialize the result property, so that we're ready at any
  1404.          * time if we need to return an error.
  1405.          */
  1406.  
  1407.         if (commWindow != None) {
  1408.         Tcl_DStringInit(&reply);
  1409.         Tcl_DStringAppend(&reply, "\0r\0-s ", 6);
  1410.         Tcl_DStringAppend(&reply, serial, -1);
  1411.         Tcl_DStringAppend(&reply, "\0-r ", 4);
  1412.         }
  1413.  
  1414.         if (!ServerSecure(dispPtr)) {
  1415.         if (commWindow != None) {
  1416.             Tcl_DStringAppend(&reply, "X server insecure (must use xauth-style authorization); command ignored", -1);
  1417.         }
  1418.         result = TCL_ERROR;
  1419.         goto returnResult;
  1420.         }
  1421.  
  1422.         /*
  1423.          * Locate the application, then execute the script.
  1424.          */
  1425.  
  1426.         for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
  1427.         if (riPtr == NULL) {
  1428.             if (commWindow != None) {
  1429.             Tcl_DStringAppend(&reply,
  1430.                 "receiver never heard of interpreter \"", -1);
  1431.             Tcl_DStringAppend(&reply, interpName, -1);
  1432.             Tcl_DStringAppend(&reply, "\"", 1);
  1433.             }
  1434.             result = TCL_ERROR;
  1435.             goto returnResult;
  1436.         }
  1437.         if (strcmp(riPtr->name, interpName) == 0) {
  1438.             break;
  1439.         }
  1440.         }
  1441.         Tk_Preserve((ClientData) riPtr);
  1442.         result = Tcl_GlobalEval(riPtr->interp, script);
  1443.         if ((commWindow != None) && (riPtr->interp != NULL)) {
  1444.         Tcl_DStringAppend(&reply, riPtr->interp->result, -1);
  1445.         if (result == TCL_ERROR) {
  1446.             char *varValue;
  1447.     
  1448.             varValue = Tcl_GetVar2(riPtr->interp, "errorInfo",
  1449.                 (char *) NULL, TCL_GLOBAL_ONLY);
  1450.             if (varValue != NULL) {
  1451.             Tcl_DStringAppend(&reply, "\0-i ", 4);
  1452.             Tcl_DStringAppend(&reply, varValue, -1);
  1453.             }
  1454.             varValue = Tcl_GetVar2(riPtr->interp, "errorCode",
  1455.                 (char *) NULL, TCL_GLOBAL_ONLY);
  1456.             if (varValue != NULL) {
  1457.             Tcl_DStringAppend(&reply, "\0-e ", 4);
  1458.             Tcl_DStringAppend(&reply, varValue, -1);
  1459.             }
  1460.         }
  1461.         }
  1462.         Tk_Release((ClientData) riPtr);
  1463.  
  1464.         /*
  1465.          * Return the result to the sender if a commWindow was
  1466.          * specified (if none was specified then this is an asynchronous
  1467.          * call).  Right now reply has everything but the completion
  1468.          * code, but it needs the NULL to terminate the current option.
  1469.          */
  1470.  
  1471.         returnResult:
  1472.         if (commWindow != None) {
  1473.         if (result != TCL_OK) {
  1474.             char buffer[20];
  1475.     
  1476.             sprintf(buffer, "%d", result);
  1477.             Tcl_DStringAppend(&reply, "\0-c ", 4);
  1478.             Tcl_DStringAppend(&reply, buffer, -1);
  1479.         }
  1480.         (void) AppendPropCarefully(dispPtr->display, commWindow,
  1481.             dispPtr->commProperty, Tcl_DStringValue(&reply),
  1482.             Tcl_DStringLength(&reply) + 1,
  1483.             (PendingCommand *) NULL);
  1484.         XFlush(dispPtr->display);
  1485.         Tcl_DStringFree(&reply);
  1486.         }
  1487.     } else if ((*p == 'r') && (p[1] == 0)) {
  1488.         int serial, code, gotSerial;
  1489.         char *errorInfo, *errorCode, *resultString;
  1490.         PendingCommand *pcPtr;
  1491.  
  1492.         /*
  1493.          *----------------------------------------------------------
  1494.          * This is a reply to some command that we sent out.  Iterate
  1495.          * over all of its options.  Stop when we reach the end of the
  1496.          * property or something that doesn't look like an option.
  1497.          *----------------------------------------------------------
  1498.          */
  1499.  
  1500.         p += 2;
  1501.         code = TCL_OK;
  1502.         gotSerial = 0;
  1503.         errorInfo = NULL;
  1504.         errorCode = NULL;
  1505.         resultString = "";
  1506.         while (((p-propInfo) < numItems) && (*p == '-')) {
  1507.         switch (p[1]) {
  1508.             case 'c':
  1509.             if (sscanf(p+2, " %d", &code) != 1) {
  1510.                 code = TCL_OK;
  1511.             }
  1512.             break;
  1513.             case 'e':
  1514.             if (p[2] == ' ') {
  1515.                 errorCode = p+3;
  1516.             }
  1517.             break;
  1518.             case 'i':
  1519.             if (p[2] == ' ') {
  1520.                 errorInfo = p+3;
  1521.             }
  1522.             break;
  1523.             case 'r':
  1524.             if (p[2] == ' ') {
  1525.                 resultString = p+3;
  1526.             }
  1527.             break;
  1528.             case 's':
  1529.             if (sscanf(p+2, " %d", &serial) == 1) {
  1530.                 gotSerial = 1;
  1531.             }
  1532.             break;
  1533.         }
  1534.         while (*p != 0) {
  1535.             p++;
  1536.         }
  1537.         p++;
  1538.         }
  1539.  
  1540.         if (!gotSerial) {
  1541.         continue;
  1542.         }
  1543.  
  1544.         /*
  1545.          * Give the result information to anyone who's
  1546.          * waiting for it.
  1547.          */
  1548.  
  1549.         for (pcPtr = pendingCommands; pcPtr != NULL;
  1550.             pcPtr = pcPtr->nextPtr) {
  1551.         if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
  1552.             continue;
  1553.         }
  1554.         pcPtr->code = code;
  1555.         if (resultString != NULL) {
  1556.             pcPtr->result = (char *) ckalloc((unsigned)
  1557.                 (strlen(resultString) + 1));
  1558.             strcpy(pcPtr->result, resultString);
  1559.         }
  1560.         if (code == TCL_ERROR) {
  1561.             if (errorInfo != NULL) {
  1562.             pcPtr->errorInfo = (char *) ckalloc((unsigned)
  1563.                 (strlen(errorInfo) + 1));
  1564.             strcpy(pcPtr->errorInfo, errorInfo);
  1565.             }
  1566.             if (errorCode != NULL) {
  1567.             pcPtr->errorCode = (char *) ckalloc((unsigned)
  1568.                 (strlen(errorCode) + 1));
  1569.             strcpy(pcPtr->errorCode, errorCode);
  1570.             }
  1571.         }
  1572.         pcPtr->gotResponse = 1;
  1573.         break;
  1574.         }
  1575.     } else {
  1576.         /*
  1577.          * Didn't recognize this thing.  Just skip through the next
  1578.          * null character and try again.
  1579.          */
  1580.  
  1581.         while (*p != 0) {
  1582.         p++;
  1583.         }
  1584.         p++;
  1585.     }
  1586.     }
  1587.     XFree(propInfo);
  1588. }
  1589.  
  1590. /*
  1591.  *--------------------------------------------------------------
  1592.  *
  1593.  * AppendPropCarefully --
  1594.  *
  1595.  *    Append a given property to a given window, but set up
  1596.  *    an X error handler so that if the append fails this
  1597.  *    procedure can return an error code rather than having
  1598.  *    Xlib panic.
  1599.  *
  1600.  * Results:
  1601.  *    None.
  1602.  *
  1603.  * Side effects:
  1604.  *    The given property on the given window is appended to.
  1605.  *    If this operation fails and if pendingPtr is non-NULL,
  1606.  *    then the pending operation is marked as complete with
  1607.  *    an error.
  1608.  *
  1609.  *--------------------------------------------------------------
  1610.  */
  1611.  
  1612. static void
  1613. AppendPropCarefully(display, window, property, value, length, pendingPtr)
  1614.     Display *display;        /* Display on which to operate. */
  1615.     Window window;        /* Window whose property is to
  1616.                  * be modified. */
  1617.     Atom property;        /* Name of property. */
  1618.     char *value;        /* Characters to append to property. */
  1619.     int length;            /* Number of bytes to append. */
  1620.     PendingCommand *pendingPtr;    /* Pending command to mark complete
  1621.                  * if an error occurs during the
  1622.                  * property op.  NULL means just
  1623.                  * ignore the error. */
  1624. {
  1625.     Tk_ErrorHandler handler;
  1626.  
  1627.     handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc,
  1628.     (ClientData) pendingPtr);
  1629.     XChangeProperty(display, window, property, XA_STRING, 8,
  1630.         PropModeAppend, (unsigned char *) value, length);
  1631.     Tk_DeleteErrorHandler(handler);
  1632. }
  1633.  
  1634. /*
  1635.  * The procedure below is invoked if an error occurs during
  1636.  * the XChangeProperty operation above.
  1637.  */
  1638.  
  1639.     /* ARGSUSED */
  1640. static int
  1641. AppendErrorProc(clientData, errorPtr)
  1642.     ClientData clientData;    /* Command to mark complete, or NULL. */
  1643.     XErrorEvent *errorPtr;    /* Information about error. */
  1644. {
  1645.     PendingCommand *pendingPtr = (PendingCommand *) clientData;
  1646.     register PendingCommand *pcPtr;
  1647.  
  1648.     if (pendingPtr == NULL) {
  1649.     return 0;
  1650.     }
  1651.  
  1652.     /*
  1653.      * Make sure this command is still pending.
  1654.      */
  1655.  
  1656.     for (pcPtr = pendingCommands; pcPtr != NULL;
  1657.         pcPtr = pcPtr->nextPtr) {
  1658.     if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
  1659.         pcPtr->result = (char *) ckalloc((unsigned)
  1660.             (strlen(pcPtr->target) + 50));
  1661.         sprintf(pcPtr->result, "no application named \"%s\"",
  1662.             pcPtr->target);
  1663.         pcPtr->code = TCL_ERROR;
  1664.         pcPtr->gotResponse = 1;
  1665.         break;
  1666.     }
  1667.     }
  1668.     return 0;
  1669. }
  1670.  
  1671. /*
  1672.  *--------------------------------------------------------------
  1673.  *
  1674.  * TimeoutProc --
  1675.  *
  1676.  *    This procedure is invoked when an unusually long amout of
  1677.  *    time has elapsed during the processing of a sent command.
  1678.  *    It checks to make sure that the target application still
  1679.  *    exists, and reschedules itself to check again later.
  1680.  *
  1681.  * Results:
  1682.  *    None.
  1683.  *
  1684.  * Side effects:
  1685.  *    If the target application has gone away abort the send
  1686.  *    operation with an error.
  1687.  *
  1688.  *--------------------------------------------------------------
  1689.  */
  1690.  
  1691. static void
  1692. TimeoutProc(clientData)
  1693.     ClientData clientData;    /* Information about command that
  1694.                  * has been sent but not yet
  1695.                  * responded to. */
  1696. {
  1697.     PendingCommand *pcPtr = (PendingCommand *) clientData;
  1698.     register PendingCommand *pcPtr2;
  1699.  
  1700.     /*
  1701.      * Make sure that the command is still in the pending list
  1702.      * and that it hasn't already completed.  Then validate the
  1703.      * existence of the target application.
  1704.      */
  1705.  
  1706.     for (pcPtr2 = pendingCommands; pcPtr2 != NULL;
  1707.         pcPtr2 = pcPtr2->nextPtr) {
  1708.     char *msg;
  1709.     if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) {
  1710.         continue;
  1711.     }
  1712.     if (!ValidateName(pcPtr2->dispPtr, pcPtr2->target,
  1713.         pcPtr2->commWindow, 0)) {
  1714.         if (ValidateName(pcPtr2->dispPtr, pcPtr2->target,
  1715.             pcPtr2->commWindow, 1)) {
  1716.         msg = "can't send to old Tk applications (versions before 4.0)";
  1717.         } else {
  1718.         msg = "target application died";
  1719.         }
  1720.         pcPtr2->code = TCL_ERROR;
  1721.         pcPtr2->result = (char *) ckalloc((unsigned) (strlen(msg) + 1));
  1722.         strcpy(pcPtr2->result, msg);
  1723.         pcPtr2->gotResponse = 1;
  1724.     } else {
  1725.         Tk_CreateTimerHandler(2000, TimeoutProc, clientData);
  1726.     }
  1727.     }
  1728. }
  1729.  
  1730. /*
  1731.  *--------------------------------------------------------------
  1732.  *
  1733.  * DeleteProc --
  1734.  *
  1735.  *    This procedure is invoked by Tcl when the "send" command
  1736.  *    is deleted in an interpreter.  It unregisters the interpreter.
  1737.  *
  1738.  * Results:
  1739.  *    None.
  1740.  *
  1741.  * Side effects:
  1742.  *    The interpreter given by riPtr is unregistered.
  1743.  *
  1744.  *--------------------------------------------------------------
  1745.  */
  1746.  
  1747. static void
  1748. DeleteProc(clientData)
  1749.     ClientData clientData;    /* Info about registration, passed
  1750.                  * as ClientData. */
  1751. {
  1752.     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
  1753.     register RegisteredInterp *riPtr2;
  1754.     NameRegistry *regPtr;
  1755.  
  1756.     regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1);
  1757.     RegDeleteName(regPtr, riPtr->name);
  1758.     RegClose(regPtr);
  1759.  
  1760.     if (registry == riPtr) {
  1761.     registry = riPtr->nextPtr;
  1762.     } else {
  1763.     for (riPtr2 = registry; riPtr2 != NULL;
  1764.         riPtr2 = riPtr2->nextPtr) {
  1765.         if (riPtr2->nextPtr == riPtr) {
  1766.         riPtr2->nextPtr = riPtr->nextPtr;
  1767.         break;
  1768.         }
  1769.     }
  1770.     }
  1771.     ckfree((char *) riPtr->name);
  1772.     riPtr->interp = NULL;
  1773.     UpdateCommWindow(riPtr->dispPtr);
  1774.     Tk_EventuallyFree((ClientData) riPtr, free);
  1775. }
  1776.  
  1777. /*
  1778.  *----------------------------------------------------------------------
  1779.  *
  1780.  * SendRestrictProc --
  1781.  *
  1782.  *    This procedure filters incoming events when a "send" command
  1783.  *    is outstanding.  It defers all events except those containing
  1784.  *    send commands and results.
  1785.  *
  1786.  * Results:
  1787.  *    False is returned except for property-change events on the
  1788.  *    given commWindow.
  1789.  *
  1790.  * Side effects:
  1791.  *    None.
  1792.  *
  1793.  *----------------------------------------------------------------------
  1794.  */
  1795.  
  1796.     /* ARGSUSED */
  1797. static Bool
  1798. SendRestrictProc(display, eventPtr, arg)
  1799.     Display *display;        /* Display from which event arrived. */
  1800.     register XEvent *eventPtr;    /* Event that just arrived. */
  1801.     char *arg;            /* Comunication window in which
  1802.                  * we're interested. */
  1803. {
  1804.     register Tk_Window comm = (Tk_Window) arg;
  1805.  
  1806.     if ((display != Tk_Display(comm))
  1807.         || (eventPtr->type != PropertyNotify)
  1808.         || (eventPtr->xproperty.window != Tk_WindowId(comm))) {
  1809.     return False;
  1810.     }
  1811.     return True;
  1812. }
  1813.  
  1814. /*
  1815.  *----------------------------------------------------------------------
  1816.  *
  1817.  * UpdateCommWindow --
  1818.  *
  1819.  *    This procedure updates the list of application names stored
  1820.  *    on our commWindow.  It is typically called when interpreters
  1821.  *    are registered and unregistered.
  1822.  *
  1823.  * Results:
  1824.  *    None.
  1825.  *
  1826.  * Side effects:
  1827.  *    The TK_APPLICATION property on the comm window is updated.
  1828.  *
  1829.  *----------------------------------------------------------------------
  1830.  */
  1831.  
  1832. static void
  1833. UpdateCommWindow(dispPtr)
  1834.     TkDisplay *dispPtr;        /* Display whose commWindow is to be
  1835.                  * updated. */
  1836. {
  1837.     Tcl_DString names;
  1838.     RegisteredInterp *riPtr;
  1839.  
  1840.     Tcl_DStringInit(&names);
  1841.     for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
  1842.     Tcl_DStringAppendElement(&names, riPtr->name);
  1843.     }
  1844.     XChangeProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin),
  1845.         dispPtr->appNameProperty, XA_STRING, 8, PropModeReplace,
  1846.         (unsigned char *) Tcl_DStringValue(&names),
  1847.         Tcl_DStringLength(&names));
  1848.     Tcl_DStringFree(&names);
  1849. }
  1850.